home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DOS.SWG / 0014_DOS Critical Errors.pas < prev    next >
Pascal/Delphi Source File  |  1993-07-17  |  10KB  |  314 lines
  1. {$S-,R-,V-,I-,N-,B-,F-}
  2.  
  3. {$IFNDEF Ver40}
  4.   {Allow overlays}
  5.   {$F+,O-,X+,A-}
  6. {$ENDIF}
  7.  
  8. UNIT CritErr;
  9.  
  10. INTERFACE
  11.  
  12. USES DOS;
  13.  
  14. TYPE
  15.     Str10 = STRING[10];
  16.     IOErrorRec = Record
  17.                  RoutineName : PathStr;
  18.                  ErrorAddr   : Str10;
  19.                  ErrorType   : Str10;
  20.                  TurboResult : Word;  { TP Error number }
  21.                  IOResult    : Word;  { DOS Extended number }
  22.                  ErrMsg      : PathStr;
  23.                  End;
  24.  
  25.  
  26. {}PROCEDURE IOResultTOErrorMessage (IOCode : WORD; VAR MSG : STRING);
  27. {}PROCEDURE GetDOSErrorMessage (VAR Msg : STRING);
  28. {}FUNCTION  UserIOError(ErrNum : INTEGER; VAR IOErr : IOErrorRec) : BOOLEAN;
  29. {}PROCEDURE CriticalErrorDOS;
  30. {}PROCEDURE CriticalErrorTP;
  31. {}PROCEDURE CriticalErrorOwn(ErrAddr: POINTER);
  32.  
  33. IMPLEMENTATION
  34.  
  35. VAR
  36.     TurboInt24: POINTER;        { Holds address of TP's error handler }
  37.  
  38.   function Hex(v: Longint; w: Integer): String;
  39.   var
  40.     s               : String;
  41.     i               : Integer;
  42.   const
  43.     hexc            : array [0 .. 15] of Char= '0123456789abcdef';
  44.   begin
  45.     s[0] := Chr(w);
  46.     for i := w downto 1 do begin
  47.       s[i] := hexc[v and $F];
  48.       v := v shr 4
  49.     end;
  50.     Hex := s;
  51.   end {Hex};
  52.  
  53.  
  54. PROCEDURE CriticalErrorDOS;
  55.  
  56.     BEGIN
  57.         SetIntVec($24,SaveInt24);
  58.     END;
  59.  
  60.  
  61.  
  62. PROCEDURE CriticalErrorTP;
  63.  
  64.     BEGIN
  65.         SetIntVec($24,TurboInt24);
  66.     END;
  67.  
  68.  
  69.  
  70. PROCEDURE CriticalErrorOwn(ErrAddr: POINTER);
  71.  
  72.     BEGIN
  73.         SetIntVec($24,ErrAddr);
  74.     END;
  75.  
  76.  
  77.  
  78. PROCEDURE GetDOSErrorMessage (VAR Msg : STRING);
  79.  
  80. TYPE pointerwords =
  81.   RECORD
  82.     ofspoint, segpoint : WORD;
  83.   END;
  84.  
  85. VAR
  86.   breakdown : pointerwords ABSOLUTE erroraddr;
  87.  
  88. BEGIN
  89. IOResultToErrorMessage (ExitCode, MSG);
  90.       WITH breakdown DO
  91.       Msg := Msg + ' $' + hex (SegPoint, 4) + ':' + hex (OfsPoint, 4);
  92. END;                          {Exitprogram}
  93.  
  94. PROCEDURE IOResultToErrorMessage (IOCode : WORD; VAR MSG : STRING);
  95. BEGIN
  96.       CASE IOCode OF
  97.       $01 : msg := 'Invalid DOS Function Number';
  98.       $02 : msg := 'File not found ';
  99.       $03 : msg := 'Path not found ';
  100.       $04 : msg := 'Too many open files ';
  101.       $05 : msg := 'File access denied ';
  102.       $06 : msg := 'Invalid file handle ';
  103.       $07 : msg := 'Memory Control Block Destroyed';
  104.       $08 : msg := 'Not Enough Memory';
  105.       $09 : msg := 'Invalid Memory Block Address';
  106.       $0A : msg := 'Environment Scrambled';
  107.       $0B : msg := 'Bad Program EXE File';
  108.       $0C : msg := 'Invalid file access mode';
  109.       $0D : msg := 'Invalid Data';
  110.       $0E : msg := 'Unknown Unit';
  111.       $0F : msg := 'Invalid drive number ';
  112.       $10 : msg := 'Cannot remove current directory';
  113.       $11 : msg := 'Cannot rename across drives';
  114.       $12 : msg := 'Disk Read/Write Error';
  115.       $13 : msg := 'Disk Write-Protected';
  116.       $14 : msg := 'Unknown Unit';
  117.       $15 : msg := 'Drive Not Ready';
  118.       $16 : msg := 'Unknown Command';
  119.       $17 : msg := 'Data CRC Error';
  120.       $18 : msg := 'Bad Request Structure Length';
  121.       $19 : msg := 'Seek Error';
  122.       $1A : msg := 'Unknown Media Type';
  123.       $1B : msg := 'Sector Not Found';
  124.       $1C : msg := 'Printer Out Of Paper';
  125.       $1D : msg := 'Disk Write Error';
  126.       $1E : msg := 'Disk Read Error';
  127.       $1F : msg := 'General Failure';
  128.       $20 : msg := 'Sharing Violation';
  129.       $21 : msg := 'Lock Violation';
  130.       $22 : msg := 'Invalid Disk Change';
  131.       $23 : msg := 'File Control Block Gone';
  132.       $24 : msg := 'Sharing Buffer Exceeded';
  133.       $32 : msg := 'Unsupported Network Request';
  134.       $33 : msg := 'Remote Machine Not Listening';
  135.       $34 : msg := 'Duplicate Network Name';
  136.       $35 : msg := 'Network Name NOT Found';
  137.       $36 : msg := 'Network BUSY';
  138.       $37 : msg := 'Device No Longer Exists On NETWORK';
  139.       $38 : msg := 'NetBIOS Command Limit Exceeded';
  140.       $39 : msg := 'Adapter Hardware ERROR';
  141.       $3A : msg := 'Incorrect Response From NETWORK';
  142.       $3B : msg := 'Unexpected NETWORK Error';
  143.       $3C : msg := 'Remote Adapter Incompatible';
  144.       $3D : msg := 'Print QUEUE FULL';
  145.       $3E : msg := 'No space For Print File';
  146.       $3F : msg := 'Print File Cancelled';
  147.       $40 : msg := 'Network Name Deleted';
  148.       $41 : msg := 'Network Access Denied';
  149.       $42 : msg := 'Incorrect Network Device Type';
  150.       $43 : msg := 'Network Name Not Found';
  151.       $44 : msg := 'Network Name Limit Exceeded';
  152.       $45 : msg := 'NetBIOS session limit exceeded';
  153.       $46 : msg := 'Filer Sharing temporarily paused';
  154.       $47 : msg := 'Network Request Not Accepted';
  155.       $48 : msg := 'Print or Disk File Paused';
  156.       $50 : msg := 'File Already Exists';
  157.       $52 : msg := 'Cannot Make Directory';
  158.       $53 : msg := 'Fail On Critical Error';
  159.       $54 : msg := 'Too Many Redirections';
  160.       $55 : msg := 'Duplicate Redirection';
  161.       $56 : msg := 'Invalid Password';
  162.       $57 : msg := 'Invalid Parameter';
  163.       $58 : msg := 'Network Device Fault';
  164.       $59 : msg := 'Function Not Supported By NETWORK';
  165.       $5A : msg := 'Required Component NOT Installed';
  166.  
  167.       (* Pascal Errors *)
  168.        94 : msg := 'EMS Memory Swap Error';
  169.        98 : msg := 'Disk Full';
  170.       100 : msg := 'Disk read error ';
  171.       101 : msg := 'Disk write error ';
  172.       102 : msg := 'File not assigned ';
  173.       103 : msg := 'File not open ';
  174.       104 : msg := 'File not open for input ';
  175.       105 : msg := 'File not open for output ';
  176.       106 : msg := 'Invalid numeric format ';
  177.       150 : msg := 'Disk is write_protected';
  178.       151 : msg := 'Unknown unit';
  179.       152 : msg := 'Drive not ready';
  180.       153 : msg := 'Unknown command';
  181.       154 : msg := 'CRC error in data';
  182.       155 : msg := 'Bad drive request structure length';
  183.       156 : msg := 'Disk seek error';
  184.       157 : msg := 'Unknown media type';
  185.       158 : msg := 'Sector not found';
  186.       159 : msg := 'Printer out of paper';
  187.       160 : msg := 'Device write fault';
  188.       161 : msg := 'Device read fault';
  189.       162 : msg := 'Hardware Failure';
  190.       163 : msg := 'Sharing Confilct';
  191.       200 : msg := 'Division by zero ';
  192.       201 : msg := 'Range check error ';
  193.       202 : msg := 'Stack overflow error ';
  194.       203 : msg := 'Heap overflow error ';
  195.       204 : msg := 'Invalid pointer operation ';
  196.       205 : msg := 'Floating point overflow ';
  197.       206 : msg := 'Floating point underflow ';
  198.       207 : msg := 'Invalid floating point operation ';
  199.       390 : msg := 'Serial Port TIMEOUT';
  200.       399 : msg := 'Serial Port NOT Responding';
  201.  
  202.      1008 : Msg := 'EMS Memory Swap Error '
  203.       ELSE
  204.           GetDosErrorMessage (Msg);
  205.       END;
  206. END;
  207.  
  208.  
  209. FUNCTION  UserIOError(ErrNum : INTEGER; VAR IOErr : IOErrorRec) : BOOLEAN;
  210. { RETURN ALL INFO ABOUT THE ERROR IF IT OCCURED}
  211. CONST
  212.       ErrTitles : ARRAY [1..5] OF STRING [10] =
  213.                   ('System', 'Disk', 'Network', 'Serial', 'Memory');
  214.  
  215. VAR
  216.     Msg       : STRING;
  217.     Regs      : REGISTERS;
  218.  
  219.     BEGIN
  220.  
  221.     UserIOError := FALSE;
  222.     FILLCHAR(IOErr,SizeOf(IOErr),#0);
  223.     IF ErrNum <=0 THEN EXIT;
  224.  
  225.     { GET DOS Extended Error }
  226.     WITH Regs DO
  227.     BEGIN
  228.       AH := $59;
  229.       BX := $00;
  230.       MSDOS (Regs);
  231.     END;
  232.  
  233.     IOResultToErrorMessage (Regs.AX, Msg);
  234.  
  235.     IOErr.RoutineName  := PARAMSTR (0);
  236.     IOErr.ErrorAddr    := Hex (SEG (ErrorAddr^), 4) + ':' + Hex (OFS (ErrorAddr^), 4);
  237.     IOErr.ErrorType    := ErrTitles[Regs.CH];
  238.     IOErr.TurboResult  := ErrNum;
  239.     IOErr.IOResult     := Regs.AX;
  240.     IOErr.ErrMsg       := Msg;
  241.  
  242.     UserIOError        := (ErrNum > 0);
  243.     END;
  244.  
  245. BEGIN
  246.  GetIntVec($24,TurboInt24);
  247.  CriticalErrorDOS;
  248. END.
  249.  
  250. { --------------------------     DEMO  --------------------- }
  251.  
  252. { EXAMPLE FOR CRITICAL ERROR HANDLER UNIT }
  253. { COMPILE AND RUN FROM DOS !!!   WILL NOT WORK PROPERLY FROM THE IDE }
  254. {$I-}   { A MUST FOR THE CRITICAL HANDLER TO WORK !!!! }
  255.  
  256. USES
  257.   CRT, CRITERR;
  258.  
  259. VAR
  260.   f:  TEXT;
  261.   i:  INTEGER;
  262.   ErrMsg : STRING;
  263.   IOErr  : IOErrorRec;
  264.  
  265. BEGIN
  266.     ClrScr;
  267.     WriteLn(' EXAMPLE PROGRAM FOR CRITICAL ERROR HANDLER ');
  268.     WriteLn;
  269.     WriteLn('Turbo Pascal replaces the operating system''s critical-error');
  270.     WriteLn('handler with its own.  For this demonstration we will generate');
  271.     WriteLn('a critical error by attempting to access a diskette that is not');
  272.     WriteLn('present.  Please ensure that no diskette is in drive A, then');
  273.     WriteLn('press RETURN...');
  274.     ReadLn;
  275.     CriticalErrorTP;
  276.     Assign(f,'A:NOFILE.$$$');
  277.     WriteLn;
  278.     WriteLn('Now attempting to access drive...');
  279.     Reset(f);
  280.     IF UserIOError(IOResult,IOErr) THEN
  281.        BEGIN
  282.        WriteLn(IOErr.RoutineName);
  283.        WriteLn(IOErr.ErrorAddr);
  284.        WriteLn(IOErr.ErrorType);
  285.        WriteLn(IOErr.TurboResult);
  286.        WriteLn(IOErr.IOResult);
  287.        WriteLn(IOErr.ErrMsg);
  288.        END;
  289.     WriteLn;
  290.     Write('Press RETURN to continue...');
  291.     ReadLn;
  292.     WriteLn;
  293.     CriticalErrorDOS;
  294.     WriteLn('With the DOS error handler restored, you will be presented');
  295.     WriteLn('with the usual "Abort, Retry, Ignore?" prompt when such an');
  296.     WriteLn('error occurs.  (Later DOS versions allow a "Fail" option.)');
  297.     WriteLn('Run this program several times and try different responses.');
  298.     Write('Press RETURN to continue...');
  299.     ReadLn;
  300.     WriteLn('Now attempting to access drive again...');
  301.     Reset(f);
  302.     IF UserIOError(IOResult,IOErr) THEN
  303.        BEGIN
  304.        WriteLn(IOErr.RoutineName);
  305.        WriteLn(IOErr.ErrorAddr);
  306.        WriteLn(IOErr.ErrorType);
  307.        WriteLn(IOErr.TurboResult);
  308.        WriteLn(IOErr.IOResult);
  309.        WriteLn(IOErr.ErrMsg);
  310.        END;
  311.     Readkey;
  312. END.
  313.  
  314.